Deutsche Edition 1/Deutsche Edition 1.iso/amok/031-040/amok35/patmatch/patmatch.mod

Text File | 1993-11-04 | 5KB | 238 lines

(*---------------------------------------------------------------------------
    :Program.     PatMatch.mod
    :Contents.      Match filenames exaktly like AmigaDos
    :Author.      Bernd Preusing
    :Address.      Gerhardstr. 16  D-2200 Elmshorn
    :Phone.      [phone]
    :Copyright.      Public Domain
    :Language.      Modula-2
    :Translator.  M2Amiga V3.3d
    :Support.      Translated from BCPL and C
    :History.      V 1.0 10-Feb-90 Bernd Preusing
    :Remark.      Took long time to find some hints!
    :Remark.      This is fully reentrant!
    :Remark.      Do NOT compile with $ S-! It's recursive!
    :Bugs.      Due to some tricks it will surely NOT run on M2Amiga V5.x!
---------------------------------------------------------------------------*)
IMPLEMENTATION MODULE PatMatch;

FROM SYSTEM    IMPORT    ADR, BYTE, ADDRESS, CAST, INLINE (*,ASSEMBLE*);

CONST EOS = 0C;
      BuffSize=128;

TYPE
     UByte = [0..255];

(* $F- checked! *)

(* $E- $F- Fastest and shortest ever seen! *)
PROCEDURE Length(Str:ARRAY OF CHAR):INTEGER;
BEGIN
  INLINE( 4CDFH,0700H, 200AH, 2200H, 4A19H, 57C9H,0FFFCH, 9041H, 4ED0H);
  (* Would you like this:? (I LOVE it!)
  ASSEMBLE(
    MOVEM.L (A7)+,A0-A2 (* A0=ret A1=Str A2=HIGH=len-1 *)
    MOVE.L    A2,D0
    MOVE.L  D0,D1
    Lp:    TST.B   (A1)+
    DBEQ    D1,Lp
    SUB.W    D1,D0      (* Even true, if no 0C at the end! *)
    JMP     (A0)
    END);
   *)
END Length;
(* $F= *)


(* $E- $F- Trick! Ändert die Parameter! Siehe Match!*)
PROCEDURE CmplPat(Pat:ARRAY OF CHAR;
          VAR Aux:ARRAY OF BYTE):BOOLEAN;
END CmplPat;
(* $F= *)
PROCEDURE cmplPat(VAR Pat:ARRAY OF CHAR;
          VAR Aux:ARRAY OF UByte):BOOLEAN;
VAR
  Ch: CHAR;
  PatP: INTEGER;
  Patlen: INTEGER;
  ErrFlag: BOOLEAN;

(* $S- *)

  PROCEDURE Rch();
  BEGIN
    IF PatP>=Patlen THEN
      Ch:=EOS
    ELSE
      Ch:=Pat[PatP];
      INC(PatP);
    END;
  END Rch;

  PROCEDURE NextItem;
  BEGIN
    IF Ch="'" THEN Rch END;
    Rch;
  END NextItem;

  PROCEDURE SetExits(List, Val:INTEGER);
  VAR A: INTEGER;
  BEGIN
    REPEAT
      A:=Aux[List];
      Aux[List]:=Val;
      List:=A;
    UNTIL List=0;
  END SetExits;

  PROCEDURE Join(A,B: INTEGER):INTEGER;
  VAR T: INTEGER;
  BEGIN
    T:=A;
    IF A=0 THEN RETURN B END;
    WHILE Aux[A]#0 DO A:=Aux[A] END;
    Aux[A]:=B;
    RETURN T;
  END Join;

(* $S= *)

  PROCEDURE Exp(AltP:INTEGER):INTEGER;
  FORWARD;

  PROCEDURE Prim():INTEGER;
  VAR A: INTEGER;
      Op: CHAR;
  BEGIN
    A:=PatP;
    Op:=Ch;
    NextItem;
    IF Op='#' THEN
      SetExits(Prim(),A)
    ELSIF Op='(' THEN
      A:=Exp(A);
      IF Ch#')' THEN ErrFlag:=TRUE END;
      NextItem;
    ELSIF (Op=EOS) OR (Op='|') OR (Op=')') THEN
      ErrFlag:=TRUE
    END;
    RETURN A;
  END Prim;

  PROCEDURE Exp(AltP:INTEGER):INTEGER;
  VAR Exits, A:INTEGER;
  BEGIN
    Exits:=0;
    LOOP
      A:=Prim();
      IF (Ch='|') OR (Ch=')') OR (Ch=EOS) THEN
        Exits:=Join(Exits,A);
        IF Ch#'|' THEN RETURN Exits END;
        Aux[AltP]:=PatP;
        AltP:=PatP;
        NextItem;
      ELSE
        SetExits(A,PatP);
      END;
    END; (* LOOP *)
  END Exp;

VAR i:INTEGER;

BEGIN
  PatP:=0;
  Patlen:=Length(Pat);
  ErrFlag:=FALSE;
  FOR i:=0 TO Patlen DO Aux[i]:=0 END;
  Rch;
  SetExits(Exp(0),0);
  RETURN ~ErrFlag;
END cmplPat;


(* $E- $F- läuft in nächste Proc hinein, spart viel Stack, da Str und Pat
 *       nicht verändert werden!
 *)
PROCEDURE Match(Pat:ARRAY OF CHAR;
        VAR Aux: ARRAY OF BYTE; Str:ARRAY OF CHAR):BOOLEAN;
END Match;
(* $F= *)
PROCEDURE match(VAR Pat:ARRAY OF CHAR;
        VAR Aux: ARRAY OF UByte; VAR Str:ARRAY OF CHAR):BOOLEAN;
VAR
  StrIndex, I, N, Strlength: INTEGER;
  P, Q: UByte;
  K, Ch: CHAR;
  Succflag: BOOLEAN;
  Wp: INTEGER;
  Work: ARRAY[0..BuffSize-1] OF UByte;

(* $S- *)
  PROCEDURE Put(N: UByte);
  TYPE IntPtr  = POINTER TO UByte;
  VAR ip, to: IntPtr;
  BEGIN
    IF N=0 THEN
      Succflag:=TRUE
    ELSE
      ip:=ADR(Work[1]);
      to:=ADR(Work[Wp]);
      WHILE CAST(LONGINT,ip)<=CAST(LONGINT,to) DO
        IF ip^=N THEN RETURN END;
        INC(ip);
      END;
      INC(Wp); Work[Wp]:=N;
    END;
  END Put;

(* $S= needs much stack! *)
BEGIN (* Match *)
  StrIndex:=0;
  Wp:=0;
  Succflag:=FALSE;
  Strlength:=Length(Str);
  Put(1);
  IF Aux[0]#0 THEN Put(Aux[0]) END;
  LOOP
    N:=1;
    WHILE N<=Wp DO
      P:=Work[N];
      K:=Pat[P-1];
      Q:=Aux[P];
      IF (K='#') THEN
        Put(P+1); Put(Q);
      ELSIF (K='%') THEN
        Put(Q)
      ELSIF (K='(') OR (K='|') THEN
        Put(P+1);
        IF Q#0 THEN Put(Q) END;
      END;
      INC(N);
    END;
    IF StrIndex>=Strlength THEN RETURN Succflag END;
    IF Wp=0 THEN RETURN FALSE END;
    Ch:=Str[StrIndex]; INC(StrIndex);
    N:=Wp;
    Wp:=0;
    Succflag:=FALSE;
    I:=1;
    WHILE I<=N DO
      P:=Work[I];
      K:=Pat[P-1];
      IF (K='?') THEN
        Put(Aux[P]);
      ELSIF (K='#') OR (K='|') OR (K='%') OR (K='(') THEN
        (* nix! *)
      ELSE
        IF K="'" THEN K:=Pat[P] END;
    IF CAP(Ch)=CAP(K) THEN Put(Aux[P]) END;
      END;
      INC(I);
    END;
  END; (* LOOP *)
END match;

(* $S- *)
END PatMatch.mod